home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / tools / namechange / ISTCR.MAC.f < prev   
Encoding:
Text File  |  1989-03-04  |  18.0 KB  |  557 lines
  1. C---------------------------------------------------------
  2. C    TOOLPACK/1    Release: 2.5
  3. C---------------------------------------------------------
  4. C
  5. C  MODIFY THE NAMES OF SYMBOLS IN A SYMBOL TABLE......
  6. C
  7.       PROGRAM ISTCR
  8.  
  9.       INTEGER IODSYI, IODSYO, JUNK, IODCMD, STATUS
  10.       INTEGER SYIPTH(81), SYOPTH(81), PROMPT(22,3),
  11.      +        CMDPTH(81)
  12.  
  13.       INTEGER GETARG, OPEN, CREATE, ZGTCMD, READCF
  14.  
  15.       DATA (PROMPT(I,1),I=1,21)/73,110,112,117,116,32,115,
  16.      +121,109,98,111,108,32,116,97,98,108,101,58,
  17.      +32,129/,
  18.      +     (PROMPT(I,2),I=1,22)/79,117,116,112,117,116,32,
  19.      +115,121,109,98,111,108,32,116,97,98,108,101,58,
  20.      +32,129/,
  21.      +     (PROMPT(I,3),I=1,15)/67,111,109,109,97,110,
  22.      +100,32,102,105,108,101,58,32,129/
  23.  
  24.       CALL ZINIT
  25.  
  26.       IF (GETARG(1,SYIPTH,81).EQ.-100) THEN
  27.         CALL ZPRMPT(PROMPT(1,1))
  28.         JUNK=ZGTCMD(SYIPTH,0)
  29.       END IF
  30.       IF (GETARG(2,SYOPTH,81).EQ.-100) THEN
  31.         CALL ZPRMPT(PROMPT(1,2))
  32.         JUNK=ZGTCMD(SYOPTH,0)
  33.       END IF
  34.       IF (GETARG(3,CMDPTH,81).EQ.-100) THEN
  35.         CALL ZPRMPT(PROMPT(1,3))
  36.         JUNK=ZGTCMD(CMDPTH,0)
  37.       END IF
  38. C
  39. C  TRY TO OPEN/CREATE THE FILES, NOTE THAT THE INPUT TABLE IS READ
  40. C  AND THEN CLOSED, TO ALLOW IT TO BE OVERWRITTEN IF REQUIRED.
  41. C
  42.       IODSYI=OPEN(SYIPTH,0)
  43.       IF (IODSYI.EQ.-1) CALL ERROR('Can''t open input symbol table.')
  44.       CALL ZYINSY(IODSYI)
  45.       CALL CLOSE(IODSYI)
  46.  
  47.       IODSYO=CREATE(SYOPTH,1)
  48.       IF (IODSYO.EQ.-1) CALL ERROR('Can''t create o/p symbol table.')
  49.  
  50.       IODCMD=OPEN(CMDPTH,0)
  51.       IF (IODCMD.EQ.-1) CALL ERROR('Can''t open command file.')
  52. C
  53. C  READ THE COMMAND FILE, THEN PROCESS THE FILE AND WRITE OUT THE
  54. C  MODIFIED SYMBOL TABLE AND QUIT.
  55. C
  56.       IF (READCF(IODCMD) .EQ. -1) CALL ERROR('Command File Error.')
  57.       CALL PROFIL(IODCMD, STATUS)
  58.       CALL ZYSOUT(IODSYO)
  59.  
  60.       IF(STATUS .EQ. -2) THEN
  61.         CALL ZMESS('[ISTCR Normal Termination].',1)
  62.       ELSE IF(STATUS .EQ. -1002) THEN
  63.         CALL ZMESS('[ISTCR Warnings Notified].',1)
  64.       ELSE
  65.         CALL ZMESS('[ISTCR Errors Notified].',1)
  66.       ENDIF
  67.       CALL ZQUIT(STATUS)
  68.  
  69.       END
  70. C-----------------------------------------------------------
  71. C
  72. C  READ THE COMMAND FILE. THE FILE CONTAINS COMMENT, COMMAND AND
  73. C  CHANGE REQUEST LINES, THE FIRST 2 TYPE ARE EASY, THE CHANGE
  74. C  REQUESTS ARE MUCH HARDER....
  75. C
  76.       INTEGER FUNCTION READCF(FD)
  77.  
  78.       INTEGER FD, STATUS, I, START, END
  79.       INTEGER BUFFER(134), PROMPT(10)
  80.       INTEGER ZGTCMD, ZLOWER, ZSPLIT, INDEXX, LENGTH
  81.  
  82.       INTEGER PATSTR(134, 1000), REPSTR(134,1000),
  83.      +        PUPAT(134,1000),MASKS(2, 1000), NAMTYP(1000)
  84.       INTEGER LIMIT
  85.       LOGICAL SELECT(1000), CASFOL, LIST, QUERY, WARN
  86.       COMMON /PATS/ PATSTR, REPSTR, LIMIT, PUPAT, SELECT, MASKS,
  87.      +              NAMTYP, CASFOL, LIST, QUERY, WARN
  88.  
  89.       SAVE /PATS/
  90.  
  91.       DATA PROMPT/67,111,109,109,97,110,100,58,32,129/
  92.  
  93.       CASFOL = .FALSE.
  94.       QUERY  = .FALSE.
  95.       LIST   = .TRUE.
  96.       WARN   = .TRUE.
  97.       READCF = -1
  98.       LIMIT  = 0
  99. C
  100. C  LOOP POINT. KEEP READING IN LINES (PROMPTING IF NECESSARY) TILL THE
  101. C              END OF THE COMMAND FILE........
  102. C
  103.    10 CONTINUE
  104.         IF(FD .EQ. 0) CALL ZPRMPT(PROMPT)
  105.         STATUS = ZGTCMD(BUFFER, FD)
  106.  
  107.         IF(STATUS .EQ. -100) THEN
  108.           IF(LIMIT .GT. 0) READCF = -2
  109.  
  110.         ELSE IF(STATUS .NE. -1) THEN
  111.  
  112.           IF(BUFFER(1) .EQ. 37) THEN
  113. C           THIS IS A COMMAND LINE.......................
  114.             IF(ZLOWER(BUFFER(2)) .EQ. 102) CASFOL = .TRUE.
  115.             IF(ZLOWER(BUFFER(2)) .EQ. 108) LIST   = .FALSE.
  116.             IF(ZLOWER(BUFFER(2)) .EQ. 113) QUERY  = .TRUE.
  117.             IF(ZLOWER(BUFFER(2)) .EQ. 119) WARN   = .FALSE.
  118.             GO TO 10
  119.  
  120.           ELSE IF(BUFFER(1) .NE. 35 .AND. STATUS .GT. 1) THEN
  121. C           THIS IS A CHANGE REQUEST LINE.......................
  122.             LIMIT = LIMIT + 1
  123.             IF(LIMIT .GT. 1000) CALL ERROR('[ISTCR: Too many changes].')
  124.             START = 1
  125.             CALL SKIPBL(BUFFER, START)
  126. C
  127. C  SEPARATE OUT THE PROGRAM UNIT SELECTOR
  128. C
  129.             IF(BUFFER(START) .EQ. 47) THEN
  130.               CALL SCOPY(BUFFER, START, PUPAT(1, LIMIT), 1)
  131.               PUPAT(1, LIMIT) = 37
  132.               START = INDEXX(PUPAT(1, LIMIT), 47)
  133.               IF(START .EQ. 0) THEN
  134.                 CALL ERROR('[ISTCR: Invalid PU selector].')
  135.               ELSE
  136.                 SELECT(LIMIT) = .TRUE.
  137.                 PUPAT(START, LIMIT) = 36
  138.                 PUPAT(START+1, LIMIT) = 129
  139.                 START = START + 1
  140.                 CALL SKIPBL(BUFFER, START)
  141.               ENDIF
  142.             ELSE
  143.               SELECT(LIMIT) = .FALSE.
  144.             ENDIF
  145. C
  146. C  NOW FIND THE END OF THE QUALIFIERS AND GET THE
  147. C  PATTERN MATCH/REPLACEMENT ACTUALLY REQUIRED.
  148. C
  149.             DO 30 END = STATUS, 1, -1
  150.               IF(BUFFER(END) .EQ. 41) THEN
  151.                 I = END + 1
  152.                 IF(ZSPLIT(BUFFER(I),PATSTR(2,LIMIT),REPSTR(1,LIMIT))
  153.      +             .NE. -1) THEN
  154.                   PATSTR(1, LIMIT) = 37
  155.                   I = LENGTH(PATSTR(1, LIMIT))
  156.                   PATSTR(I+1, LIMIT) = 36
  157.                   PATSTR(I+2, LIMIT) = 129
  158.                 ELSE
  159.                   CALL ERROR('[ISTCR: Pattern Split Error].')
  160.                 ENDIF
  161.                 BUFFER(END+1) = 129
  162.                 GO TO 20
  163.               ENDIF
  164.    30       CONTINUE
  165.             CALL ERROR('[ISTCR: No Pattern Specified].')
  166. C
  167. C  NOW FIND OUT ABOUT THE QUALIFIERS
  168. C
  169.    20       CONTINUE
  170.             BUFFER(END + 1) = 129
  171.             CALL ZTOLOW(BUFFER(START))
  172.             CALL GETVAL(BUFFER(START))
  173.           ENDIF
  174.  
  175.           GO TO 10
  176.         ENDIF
  177.  
  178.       END
  179. C ----------------------------------------------------------------------
  180. C
  181. C  ROUTINE TO IDENTIFY THE SYMBOL QUALIFIERS
  182. C
  183.       SUBROUTINE GETVAL(BUFFER)
  184.  
  185.       INTEGER C1, C2, C3, ZIOR, GETW, LENT, INDEXX, I, J,
  186.      + VALUE
  187.       INTEGER BUFFER(*), START, END, POINT, NAME(134),
  188.      +  WORD(134), TYPES(10)
  189.       INTEGER PATSTR(134, 1000), REPSTR(134,1000),
  190.      +        PUPAT(134,1000),MASKS(2, 1000), NAMTYP(1000)
  191.       INTEGER LIMIT
  192.       LOGICAL SELECT(1000), CASFOL, LIST, QUERY, WARN
  193.       COMMON /PATS/ PATSTR, REPSTR, LIMIT, PUPAT, SELECT, MASKS,
  194.      +              NAMTYP, CASFOL, LIST, QUERY, WARN
  195.  
  196.       SAVE /PATS/, TYPES
  197.  
  198.       DATA TYPES/98,112,105,114,108,120,100,99,103,129/
  199. C
  200. C  FIRSTLY GET THE SYMBOL TYPE, IGNORING ANY LEADING 'S_' THAT
  201. C  MAY BE PRESENT.......
  202. C
  203.       START = 1
  204.       IF(BUFFER(1) .EQ. 115 .AND.
  205.      +   BUFFER(2) .EQ. 95) START = START + 2
  206.       C1 = BUFFER(START)
  207.       C2 = BUFFER(START+1)
  208.  
  209.       IF(C1 .EQ. 99) THEN
  210.         NAMTYP(LIMIT) = 1
  211.       ELSE IF(C1 .EQ. 110) THEN
  212.         NAMTYP(LIMIT) = 2
  213.       ELSE IF(C1 .EQ. 112  .AND. C2 .EQ. 117) THEN
  214.         NAMTYP(LIMIT) = 3
  215.       ELSE IF(C1 .EQ. 118) THEN
  216.         NAMTYP(LIMIT) = 4
  217.       ELSE IF(C1 .EQ. 112  .AND. C2 .EQ. 97) THEN
  218.         NAMTYP(LIMIT) = 5
  219.       ELSE IF(C1 .EQ. 112  .AND. C2 .EQ. 114) THEN
  220.         NAMTYP(LIMIT) = 6
  221.       ELSE IF(C1 .EQ. 115) THEN
  222.         NAMTYP(LIMIT) = 7
  223.       ELSE IF(C1 .EQ. 101) THEN
  224.         NAMTYP(LIMIT) = 8
  225.       ELSE
  226.         CALL ERROR('[ISTCR: Unknown Symbol Type].')
  227.       ENDIF
  228.  
  229.  
  230.       IF(NAMTYP(LIMIT) .EQ. 1) THEN
  231. C       COMMON BLOCKS, NO FURTHER QUALIFICATION RELEVANT..........
  232.  
  233.       ELSE
  234. C       GET DATA TYPES, IF ANY.......................
  235.         I = INDEXX(BUFFER, 58)
  236.         IF(I .EQ. 0) THEN
  237.           MASKS(1, LIMIT) = 1023
  238.  
  239.         ELSE
  240.           MASKS(1, LIMIT) = 0
  241. 100       CONTINUE
  242.             I = I + 1
  243.             J = INDEXX(TYPES, BUFFER(I))
  244.             IF(J .NE. 0) THEN
  245.               VALUE = 2**(J-1)
  246.               MASKS(1, LIMIT) = ZIOR(MASKS(1, LIMIT), VALUE)
  247.               GO TO 100
  248.             ENDIF
  249.         ENDIF
  250.  
  251. C       FIND THE QUALIFIERS............................
  252.         START = INDEXX(BUFFER, 40) + 1
  253.         MASKS(2, LIMIT) = 0
  254.  
  255. 20      CONTINUE
  256.         LENT = GETW(BUFFER, START, WORD)
  257.         IF(LENT .NE. 0) THEN
  258.           C1 = WORD(1)
  259.           C2 = WORD(2)
  260.           C3 = WORD(3)
  261.           IF(C1 .EQ. 97 .AND. C2 .EQ. 114) THEN
  262.             MASKS(2, LIMIT) = ZIOR(MASKS(2, LIMIT), 2048)
  263.           ELSE IF(C1 .EQ. 97  .AND. C2 .EQ. 115) THEN
  264.             MASKS(2, LIMIT) = ZIOR(MASKS(2, LIMIT), 16)
  265.           ELSE IF(C1 .EQ. 99  .AND. C2 .EQ. 111) THEN
  266.             MASKS(2, LIMIT) = ZIOR(MASKS(2, LIMIT), 1024)
  267.           ELSE IF(C1 .EQ. 100  .AND. C2 .EQ. 97) THEN
  268.             MASKS(2, LIMIT) = ZIOR(MASKS(2, LIMIT), 128)
  269.           ELSE IF(C1 .EQ. 100  .AND. C2 .EQ. 117) THEN
  270.             MASKS(2, LIMIT) = ZIOR(MASKS(2, LIMIT), 4)
  271.           ELSE IF(C1 .EQ. 101  .AND. C2 .EQ. 113) THEN
  272.             MASKS(2, LIMIT) = ZIOR(MASKS(2, LIMIT), 512)
  273.           ELSE IF(C1.EQ.101.AND.C2.EQ.120.AND.C3.EQ.112) THEN
  274.             MASKS(2, LIMIT) = ZIOR(MASKS(2, LIMIT), 16384)
  275.           ELSE IF(C1.EQ.101.AND.C2.EQ.120.AND.C3.EQ.116) THEN
  276.             MASKS(2, LIMIT) = ZIOR(MASKS(2, LIMIT), 1)
  277.           ELSE IF(C1 .EQ. 102)THEN
  278.             MASKS(2, LIMIT) = ZIOR(MASKS(2, LIMIT), 8192)
  279.           ELSE IF(C1.EQ.105.AND.C2.EQ.110.AND.C3.EQ.100) THEN
  280.             MASKS(2, LIMIT) = ZIOR(MASKS(2, LIMIT), 65536)
  281.           ELSE IF(C1.EQ.105.AND.C2.EQ.110.AND.C3.EQ.116) THEN
  282.             MASKS(2, LIMIT) = ZIOR(MASKS(2, LIMIT), 2)
  283.           ELSE IF(C1 .EQ. 114) THEN
  284.             MASKS(2, LIMIT) = ZIOR(MASKS(2, LIMIT), 64)
  285.           ELSE IF(C1 .EQ. 115  .AND. C2 .EQ. 101) THEN
  286.             MASKS(2, LIMIT) = ZIOR(MASKS(2, LIMIT), 32)
  287.           ELSE IF(C1 .EQ. 115  .AND. C2 .EQ. 102) THEN
  288.             MASKS(2, LIMIT) = ZIOR(MASKS(2, LIMIT), 256)
  289.           ELSE IF(C1 .EQ. 115  .AND. C2 .EQ. 116) THEN
  290.             MASKS(2, LIMIT) = ZIOR(MASKS(2, LIMIT), 4096)
  291.           ELSE IF(C1 .EQ. 115  .AND. C2 .EQ. 117) THEN
  292.             MASKS(2, LIMIT) = ZIOR(MASKS(2, LIMIT), 32768)
  293.           ELSE IF(C1 .EQ. 117) THEN
  294.             MASKS(2, LIMIT) = ZIOR(MASKS(2, LIMIT), 125936)
  295.           ELSE
  296.           ENDIF
  297.  
  298.           GO TO 20
  299.         ENDIF
  300.       ENDIF
  301.  
  302.       END
  303. C ----------------------------------------------------------------------
  304. C
  305. C  GET THE NEXT WORD. A WORD IS DEFINED AS BEING AN UNBROKEN STRING
  306. C  OR ALPHABETIC CHARACTERS. THE POINTER 'START' IS RETURNED POINTING
  307. C  TO THE FIRST CHARACTER OF THE NEXT WORD.
  308. C
  309.       INTEGER FUNCTION GETW(BUFFER, START, WORD)
  310.  
  311.       INTEGER START, TYPE
  312.       INTEGER WORD(*), BUFFER(*)
  313.  
  314.       GETW = 0
  315.       CALL SKIPBL(BUFFER, START)
  316.    10 CONTINUE
  317.         IF(TYPE(BUFFER(START)) .EQ. 1) THEN
  318.           GETW = GETW + 1
  319.           WORD(GETW) = BUFFER(START)
  320.         ELSE
  321.           WORD(GETW+1) = 129
  322.    20     CONTINUE
  323.             START = START + 1
  324.             IF(BUFFER(START) .EQ. 129) RETURN
  325.           IF(TYPE(BUFFER(START)) .NE. 1) GO TO 20
  326.           RETURN
  327.         ENDIF
  328.         START = START + 1
  329.       GO TO 10
  330.  
  331.       END
  332. C ----------------------------------------------------------------------
  333. C
  334. C  PROFIL   -   Process the file
  335. C               GO THROUGH, CHECKING TO SEE IF ANY OF THE SYMBOLS
  336. C               MATCH THE CHANGE COMMANDS AND THEN TRYING TO CHANGE
  337. C               THEM.
  338. C
  339.  
  340.       SUBROUTINE PROFIL(FD, STATE)
  341.  
  342.       INTEGER SYMPTR, BITS, NSYMS, I, TEST, PU, STATUS, JUNK1, JUNK2,
  343.      +        FD, STRPTR, TEST1, STATE
  344.       INTEGER SYMBOL(8), BUFFER(134), EXTNAM(134),
  345.      +        SYMIDX(1000), PUNAME(134), PROMPT(20), RESULT(8)
  346.       INTEGER ZYGNSY, ZIAND, ZYASTR, ZYFSYM, ZPREPL, ZPFIND, ZSETR,
  347.      +        ZSETP, ZGTCMD, EQUAL, ZYESNO
  348.  
  349.       LOGICAL MATCH, LEGAL, TEST2
  350.  
  351.       INTEGER PATSTR(134, 1000), REPSTR(134,1000),
  352.      +        PUPAT(134,1000),MASKS(2, 1000), NAMTYP(1000),
  353.      +        LIMIT
  354.       LOGICAL SELECT(1000), CASFOL, LIST, QUERY, WARN
  355.       COMMON /PATS/ PATSTR, REPSTR, LIMIT, PUPAT, SELECT, MASKS,
  356.      +              NAMTYP, CASFOL, LIST, QUERY, WARN
  357.  
  358.       SAVE /PATS/
  359.  
  360.       DATA PROMPT/32,32,32,69,110,116,101,114,32,110,
  361.      +            101,119,32,110,97,109,101,58,32,129/
  362.  
  363.       PU = 1
  364.       STATE = -2
  365. C
  366. C  LOOP POINT. COME BACK TO HERE TO START PROCESSING EACH PROGRAM UNIT,
  367. C              ALL IS OVER WHEN A PROGRAM UNIT HAS NO SYMBOLS.
  368. C
  369.    10 CONTINUE
  370.  
  371.         CALL ZYGSSI(SYMIDX, NSYMS, PU)
  372.         IF (NSYMS .EQ. 0) RETURN
  373.  
  374.         DO 20 I =1, NSYMS
  375.           CALL ZYGTSY(SYMIDX(I), SYMBOL)
  376.           IF(SYMBOL(1) .EQ. 4) THEN
  377.             CALL ZYGTST(SYMBOL(2), PUNAME)
  378.             IF(LIST) THEN
  379.               CALL ZCHOUT('In program unit: .', 1)
  380.               CALL ZPTMES(PUNAME, 1)
  381.             ENDIF
  382.             GO TO 15
  383.           ENDIF
  384.    20   CONTINUE
  385.  
  386.    15 CONTINUE
  387.  
  388.         DO 40 TEST = 1, LIMIT
  389. C
  390. C  IS THERE A PROGRAM UNIT SELECTION TO BE MADE?
  391. C
  392.           IF(SELECT(TEST)) THEN
  393.             STATUS = ZSETP(PUPAT(1, TEST), CASFOL)
  394.             IF(ZPFIND(PUNAME,1,JUNK1, JUNK2) .EQ. -3) GO TO 40
  395.           ENDIF
  396.  
  397.           DO 30 I = 1, NSYMS
  398.             CALL ZYGTSY(SYMIDX(I), SYMBOL)
  399. C
  400. C  FIRST CHECK SYMBOL SELECTION
  401. C
  402.             MATCH = .FALSE.
  403.             IF(SYMBOL(1) .EQ. 2) THEN
  404.               IF(NAMTYP(TEST) .EQ. 1) MATCH = .TRUE.
  405.             ELSE IF(SYMBOL(1) .EQ. 3) THEN
  406.               IF(NAMTYP(TEST) .EQ. 2) MATCH = .TRUE.
  407.             ELSE IF(SYMBOL(1) .EQ. 4) THEN
  408.               IF(NAMTYP(TEST) .EQ. 3) MATCH = .TRUE.
  409.             ELSE IF(SYMBOL(1) .EQ. 5) THEN
  410.               IF(NAMTYP(TEST) .EQ. 4) MATCH = .TRUE.
  411.             ELSE IF(SYMBOL(1) .EQ. 6) THEN
  412.               IF(NAMTYP(TEST) .EQ. 5) MATCH = .TRUE.
  413.             ELSE IF(SYMBOL(1) .EQ. 7) THEN
  414.               IF(NAMTYP(TEST) .EQ. 6) MATCH = .TRUE.
  415.             ELSE IF(SYMBOL(1) .EQ. 8) THEN
  416.               IF(NAMTYP(TEST) .EQ. 7) MATCH = .TRUE.
  417.             ELSE IF(SYMBOL(1) .EQ. 9) THEN
  418.               IF(NAMTYP(TEST) .EQ. 8) MATCH = .TRUE.
  419.             ENDIF
  420. C
  421. C  NOW CHECK DATA TYPE
  422. C
  423.             IF(MATCH) THEN
  424.               MATCH = .FALSE.
  425.               IF(SYMBOL(4) .EQ. -2) BITS = 1
  426.               IF(SYMBOL(4) .EQ. -1) BITS = 2
  427.               IF(SYMBOL(4) .EQ. 1) BITS = 4
  428.               IF(SYMBOL(4) .EQ. 2) BITS = 8
  429.               IF(SYMBOL(4) .EQ. 3) BITS = 16
  430.               IF(SYMBOL(4) .EQ. 4) BITS = 32
  431.               IF(SYMBOL(4) .EQ. 5) BITS = 64
  432.               IF(SYMBOL(4) .EQ. 6) BITS = 128
  433.               IF(SYMBOL(4) .EQ. 8) BITS = 256
  434.               IF(ZIAND(BITS, MASKS(1, TEST)) .NE. 0) MATCH = .TRUE.
  435.             ENDIF
  436. C
  437. C  NOW CHECK ATTRIBUTE BITS
  438. C
  439.             IF(MATCH .AND.
  440.      +         ((ZIAND(SYMBOL(6), MASKS(2, TEST)) .NE. 0)
  441.      +         .OR. (MASKS(2, TEST) .EQ. 0)))THEN
  442.               CALL ZYGTST(SYMBOL(2), EXTNAM)
  443.               STATUS = ZSETP(PATSTR(1, TEST), CASFOL)
  444.               STATUS = ZSETR(REPSTR(1, TEST))
  445.               IF(STATUS .EQ. -1) RETURN
  446.               STATUS = ZPREPL(EXTNAM, BUFFER, .FALSE.)
  447.  
  448.               IF(STATUS .EQ. -2) THEN
  449.    13           CONTINUE
  450.                 TEST1 = ZYFSYM(BUFFER, PU, RESULT)
  451.                 TEST2 = LEGAL(BUFFER, STATE)
  452.                 IF(TEST1 .EQ. -1 .AND. TEST2) THEN
  453.                   IF(QUERY) THEN
  454.                     IF(.NOT. LIST) THEN
  455.                       CALL ZCHOUT('In program unit: .', 1)
  456.                       CALL PUTLIN(PUNAME, 1)
  457.                     ENDIF
  458.                     CALL ZCHOUT(' About to change .', 1)
  459.                     CALL PUTLIN(EXTNAM, 1)
  460.                     CALL ZCHOUT(' to .', 1)
  461.                     CALL ZPTMES(BUFFER, 1)
  462.                     IF(ZYESNO(-3) .EQ. -3) GO TO 30
  463.                   ENDIF
  464.                   STRPTR = ZYASTR(BUFFER)
  465.                   CALL ZYSATT(SYMIDX(I), 2, STRPTR)
  466.                   IF(LIST) THEN
  467.                     CALL ZCHOUT('    .', 1)
  468.                     CALL PUTLIN(EXTNAM, 1)
  469.                     CALL ZCHOUT(' changed to .', 1)
  470.                     CALL ZPTMES(BUFFER, 1)
  471.                   ENDIF
  472.                 ELSE IF(EQUAL(BUFFER, EXTNAM) .EQ. -2) THEN
  473. C                 NAMES ARE IDENTICAL
  474.                 ELSE
  475.                   IF(FD .NE. 0) THEN
  476.                     CALL ZCHOUT('In program unit: .', 2)
  477.                     CALL PUTLIN(PUNAME, 2)
  478.                     CALL ZCHOUT(' - Unable to change .', 2)
  479.                     CALL PUTLIN(EXTNAM, 2)
  480.                     CALL ZCHOUT(' to .', 2)
  481.                     CALL ZPTMES(BUFFER, 2)
  482.                     CALL ERROR('[ISTCR: Error Termination].')
  483.                   ELSE
  484.                     IF(.NOT. LIST) THEN
  485.                       CALL ZCHOUT('In program unit: .', 1)
  486.                       CALL PUTLIN(PUNAME, 1)
  487.                     ENDIF
  488.                     IF(TEST1 .NE. -1) THEN
  489.                       CALL ZCHOUT(' - Name clash changing .', 1)
  490.                     ELSE
  491.                       CALL ZCHOUT(' - Unable to change .', 1)
  492.                     ENDIF
  493.                     CALL PUTLIN(EXTNAM, 1)
  494.                     CALL ZCHOUT(' to .', 1)
  495.                     CALL ZPTMES(BUFFER, 1)
  496.                     CALL ZPRMPT(PROMPT)
  497.                     STATUS = ZGTCMD(BUFFER, FD)
  498.                     IF(STATUS .EQ. -100 .OR. STATUS .EQ. -1) CALL
  499.      +                  ERROR('[ISTCR: Error Termination].')
  500.                     GO TO 13
  501.                   ENDIF
  502.                 ENDIF
  503.               ENDIF
  504.             ENDIF
  505.    30     CONTINUE
  506.  
  507.    40   CONTINUE
  508.  
  509.         PU = PU + 1
  510.  
  511.       GO TO 10
  512.  
  513.       END
  514. C----------------------------------------------------------
  515. C
  516. C  CHECK THE LEGALITY OF A SYMBOL NAME. AT THE MOMENT A LEGAL
  517. C  SYMBOL NAME IS ANYTHING WITH 1 TO 6 CHARACTERS EACH OF WHICH
  518. C  IS AN UPPERCASE LETTER OR A DIGIT AND THE FIRST OF WHICH IS A
  519. C  LETTER.
  520. C
  521. C  THIS CONCEPT OF LEGALITY CAN BE CUSTOMISED TO LOCAL REQUIREMENTS
  522. C  (E.G. ARBITRARY LENGTH, ANY CASE AND INCLUDING UNDERLINES).
  523. C
  524.       LOGICAL FUNCTION LEGAL(NAME, STATE)
  525.  
  526.       INTEGER NAME(*), STATE
  527.       LOGICAL TEST1, TEST2
  528.  
  529.       INTEGER PATSTR(134, 1000), REPSTR(134,1000),
  530.      +        PUPAT(134,1000),MASKS(2, 1000), NAMTYP(1000),
  531.      +        LIMIT
  532.       LOGICAL SELECT(1000), CASFOL, LIST, QUERY, WARN
  533.       COMMON /PATS/ PATSTR, REPSTR, LIMIT, PUPAT, SELECT, MASKS,
  534.      +              NAMTYP, CASFOL, LIST, QUERY, WARN
  535.  
  536.       SAVE /PATS/
  537.  
  538.       LEGAL = .TRUE.
  539.  
  540.       CALL ZLEGAL(NAME, TEST1, TEST2)
  541.       IF(.NOT. TEST1) THEN
  542.         IF(TEST2)THEN
  543.           IF(WARN) THEN
  544.             IF(STATE .EQ. -2) STATE = -1002
  545.             CALL ZCHOUT('CR: Warning, name is non-standard: .', 1)
  546.             CALL ZPTMES(NAME, 1)
  547.           ENDIF
  548.         ELSE
  549.           CALL ZCHOUT('CR: Error, name is illegal: .', 1)
  550.           CALL ZPTMES(NAME, 1)
  551.           STATE = -1
  552.           LEGAL = .FALSE.
  553.         ENDIF
  554.       ENDIF
  555.  
  556.       END
  557.